Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d18/tools.arc/TOOLS.PAS

Pascal/Delphi Source File | 1989-03-20 | 11.8 KB | 456 lines

{
TOOLS.PAS - Screen & I/O Tools for MS and IBM Pascal
copyright 1984 Ronald Florence

   WRXY - writes an lstring, with specified screen attribute, at row/col
   DOXY - sets a row/col/len to a char and screen attribute
   CLS - clears from 1 to 25 rows of the screen
   LOCATE - places cursor at a row/col (1..25, 1..80)
   CURSOR_ROW, CURSOR_COL - returns cursor location (1..25, 1..80)
   INKEY - returns the next char pressed
   ESCAPE - returns true if Esc is pressed
   RDCHAR - waits for a char in a declared set
   YES - waits for y/n; returns true if y
   UPCASE - changes a string to upper case
   RDSTR - inputs a string
   RDINT - inputs an integer between low/high
   RDREAL - inputs a decimal real
      (RDSTR, RDINT, RDREAL all clear and start over if Esc is pressed during
       entry. If Esc is pressed with no entry, they return false. All three
       need a writeln if used in tty-type entry. Usage:
      var i: integer;
         begin
                write ('Prompt: ');
            if not rdint (i, -1, 100) then return;
        writeln;                                 )
   PEEK, POKE - segmented direct address procedure/functions
   OK_DISP - sets video address, returns false if not 80 col text display
   PUSHSCREEN - saves current screen
   POPSCREEN - retrieves saved screen
   PRESSED - returns next key (inc. extended ASCII, function keys, etc.)
      (usage:
         var key: keytype;
            begin
                key:= pressed;
                if key.reg=chr(27) then do_escape
                else if key.ex=35 {alt H} then do_help
                else...)


To use the whole package, compile it as a unit, $include the interface and
put a "uses TOOLS" statement in your program heading. If you only need a few
of the functions and procedures, put the declarations back on the ones you
need and $include just the code you need in your program. Please include the
statement "copyright 1984 Ronald Florence" in any program incorporating these
procedures and functions.

Good luck. If you make any useful additions or changes, please write me:

      Ronald Florence
      114 Five Mile River Road
      Darien, CT 06820
}


interface;

unit tools
   (wrxy, doxy, cls, locate, cursor_row, cursor_col,
    inkey, escape, rdchar, yes, upcase, rdint, rdreal, rdstr,
    peek, poke, ok_disp, pushscreen, popscreen, pressed);

type
   charset = set of char;
   keytype = record
               ex: byte;
               reg: char
             end;

procedure wrxy (const msg: lstring; row, col: sint; att: char);
procedure doxy (ch: char; row, col: sint; att: char; len:sint);
procedure cls (upper, lower: sint);
procedure locate (y,x: sint);
function cursor_row: sint;
function cursor_col: sint;
function inkey: char;
function escape: boolean;
function rdchar (okchars:charset): char;
function yes: boolean;
procedure upcase (var s: string);
function rdstr (var s: string): boolean;
function rdint (var i:integer; low, high: integer): boolean;
function rdreal (var r:real): boolean;
function peek (segment, offset: word): byte;
procedure poke (segment, offset: word; argval: byte);
function ok_disp: boolean;
procedure pushscreen;
procedure popscreen;
function pressed: keytype;
end;



implementation of tools;

type
   screenchar = record
                   character, attribute: char;
                end;
   screentype = array [1..25, 1..80] of screenchar;
   curs_pos = record
                 col, row: byte;
              end;

const
   blank = ' ';
   norm = chr(7);

var [static]
   screen: ads of screentype;
   curs : ads of curs_pos;
   cls_start: ads of char;
   video_ads: word;
   snapscreen : ^screentype;
   snapcurs : curs_pos;

value
   curs.s:= #0040;
   curs.r:= #0050;
   screen.r:= #0;

procedure ptyuqq (len:word; loc:adsmem); extern;
function dosxqq (comm, parm: word): byte; extern;

procedure wrxy;
var [static]
   i: sint;
begin
   for i := 1 to ord(msg.len) do begin
      screen^[row, col].character := msg[i];
      screen^[row, col].attribute := att;
      col := col+1
   end
end;

procedure doxy;
var [static]
   i: sint;
begin
   for i := 1 to len do begin
      screen^[row, col].character := ch;
      screen^[row, col].attribute := att;
      col := col+1
   end;
end;

procedure cls;
type
   screenline = array [1..80] of screenchar;
var [static]
   blankline: screenline;
value
   blankline:= screenline (do 80 of screenchar (blank, norm));
begin
   cls_start.r:= 160 * wrd(upper-1);
   for var line:= upper to lower do
      [movesl (ads blankline, cls_start, 160);
       cls_start.r:= cls_start.r + 160]
end;

procedure locate;
const
   bs = chr(8);
begin
   curs^.col:= wrd(x);
   curs^.row:= wrd(y-1);
   ptyuqq (1, ads bs)
end;

function cursor_row;
begin
   cursor_row:= ord(curs^.row + 1)
end;

function cursor_col;
begin
   cursor_col:= ord (curs^.col + 1)
end;

function inkey;
var
   b: byte;
begin
   repeat b:= dosxqq(6,255) until b <> 0;
   inkey:= chr(b)
end;

function escape;
var
   b: byte;
begin
   b:= dosxqq(6,255);
   escape:= b=27
end;

function rdchar;
var
   c: char;
begin
   repeat
      c:= inkey;
      if c in ['a'..'z'] then c:= chr (ord(c) - 32)
   until c in okchars;
   write (c);
   rdchar:= c
end;

function yes;
var
   c: char;
begin
   repeat c:= inkey until c in ['y','Y','n','N'];
   write (c);
   yes:= c in ['y','Y']
end;

procedure upcase;
begin
   for var c:= 1 to upper(s) do
      if s[c] in ['a'..'z'] then s[c]:= chr(ord(s[c])-32)
end;

function rdstr;
label
   again;
var
   c: char;
   k: sint;
begin
   again:
   k:= 1;
   repeat
      c:= inkey;
      case c of
         chr(8):  if k > 1 then begin
                     write (chr(8)*blank*chr(8));
                     s[k]:= blank;
                     k:= k-1
                  end;
         chr(27): if k = 1 then begin
                     rdstr:= false;
                     return
                  end
                  else begin
                     for var d:= 1 to k do s[d]:= blank;
                     doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
                     locate (cursor_row, cursor_col-k+1);
                     goto again
                  end;
         chr(32)..chr(126): if k <= upper(s) then
                               begin
                                  write (c);
                                  s[k]:= c;
                                  k:= k+1
                               end
                             else write (chr(7))
         otherwise
      end
   until c=chr(13);
   if k < upper(s) then for var d:= k to upper(s) do s[d]:= blank;
   rdstr:= true
end;

function rdint;
label
   again;
var
   neg: boolean;
   k: sint;
   c: char;
begin
   again:
   k:= 1;
   i:= 0;
   neg:= false;
   repeat
      c:= inkey;
      case c of
         chr(45):  if k=1 then begin
                      write (c);
                      neg:= true;
                      k:= k+1
                   end
                   else write (chr(7));
         '0'..'9': begin
                      write (c);
                      i:= i * 10 + ord(c) - ord('0');
                      k:= k+1
                   end;
         chr(8) :  if k > 1 then begin
                      write (chr(8)*blank*chr(8));
                      if neg and (k=2) then neg:= false
                      else i:= i div 10;
                      k:= k-1;
                   end;
         chr (13): ;
         chr(27):  if k = 1 then begin
                      rdint:= false;
                      return
                   end
                   else begin
                      doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
                      locate (cursor_row, cursor_col-k+1);
                      goto again
                   end;
         otherwise write (chr(7))
      end
   until c = chr(13);
   if neg then i:= - i;
   if (i < low) or (i > high) then begin
      write (chr(7));
      doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
      locate (cursor_row, cursor_col-k+1);
      goto again
   end
   else rdint:= true
end;

function rdreal;
label
   again;
var
   left, right: integer4;
   expon: real;
   neg, decimal : boolean;
   k: sint;
   c: char;
begin
   again:
   k:= 1;
   expon:= 1;
   left:= 0;
   right:= 0;
   neg:= false;
   decimal:= false;
   repeat
      c:= inkey;
      case c of
         chr(45):  if k=1 then begin
                      write (c);
                      neg:= true;
                      k:= k+1
                   end
                   else write (chr(7));
         chr(46):  if not decimal then begin
                      write (c);
                      decimal:= true;
                      k:= k+1;
                   end
                   else write (chr(7));
         '0'..'9': begin
                      write (c);
                      if not decimal then begin
                         left:= left * 10 + ord(c) - ord('0');
                         k:= k+1
                      end
                      else begin
                         right:= right * 10 + ord (c) - ord ('0');
                         expon:= expon / 10;
                         k:= k+1
                      end
                   end;
         chr(8) :  if k > 1 then begin
                      write (chr(8)*blank*chr(8));
                      if neg and (k=2) then neg:= false
                      else if not decimal then left:= left div 10
                      else if decimal and (expon=1) then decimal:= false
                      else begin
                         right:= right div 10;
                         expon:= expon * 10
                      end;
                      k:= k-1
                   end;
         chr (13): ;
         chr(27):  if k = 1 then begin
                      rdreal:= false;
                      return
                   end
                   else begin
                      doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
                      locate (cursor_row, cursor_col-k+1);
                      goto again
                   end;
         otherwise write (chr(7))
      end;
   until c = chr(13);
   r:= left + expon * float4(right);
   if neg then r:= - r;
   rdreal:= true
end;

function peek;
var addr: ads of byte;
begin
   addr.s:= segment;
   addr.r:= offset;
   peek:= addr^
end;

procedure poke;
var addr: ads of byte;
begin
   addr.s:= segment;
   addr.r:= offset;
   addr^:= argval
end;

function ok_disp;
begin
   case peek(#0040, #0049) of
      7 : video_ads:= #B000;    {monochrome board}
      2,3: video_ads:= #B800    {80 col graphics board}
      otherwise
         [writeln ('Program requires 80 column text display');
          ok_disp:= false;
          return]
   end;
   screen.s:= video_ads;
   cls_start.s:= video_ads;
   ok_disp:= true
end;

procedure pushscreen;
var
   oldscreen : ads of byte;
begin
   oldscreen.s := video_ads;
   oldscreen.r := 0;
   new(snapscreen);
   movesl(oldscreen, ads snapscreen^, 4000);
   snapcurs.row:= wrd(cursor_row);
   snapcurs.col:= wrd(cursor_col)
end;

procedure popscreen;
var
   oldscreen : ads of byte;
begin
   oldscreen.s := video_ads;
   oldscreen.r := 0;
   movesl(ads snapscreen^, oldscreen, 4000);
   locate (ord(snapcurs.row), ord(snapcurs.col));
   dispose(snapscreen)
end;

function pressed;
var
   b: byte;
begin
   b:= dosxqq (7, 0);
   pressed.reg:= chr(b);
   if b <> 0 then pressed.ex:= 0
   else pressed.ex:= dosxqq (7, 0)
end;

end.